Planet Source Code Jumbo …e CD Visual Basic 1 to 7/3_2004-2005.ISO/Data/Zips/Physics_Pa1816171182004.psc/Physics Demo/Array.frm

Text File | 2004-11-09 | 10KB | 355 lines

VERSION 5.00
Begin VB.Form Form1
   AutoRedraw      =   -1  'True
   BackColor       =   &H00000000&
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "Advanced Physics Array"
   ClientHeight    =   10080
   ClientLeft      =   1980
   ClientTop       =   450
   ClientWidth     =   9015
   Icon            =   "Array.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   MousePointer    =   2  'Cross
   ScaleHeight     =   10080
   ScaleWidth      =   9015
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Begin VB.HScrollBar BallsBar
      Height          =   255
      LargeChange     =   200
      Left            =   7080
      Max             =   1000
      Min             =   1
      TabIndex        =   4
      Top             =   5640
      Value           =   20
      Width           =   1935
   End
   Begin VB.HScrollBar WideBar
      Height          =   255
      LargeChange     =   5
      Left            =   7080
      Max             =   20
      Min             =   1
      TabIndex        =   0
      Top             =   5400
      Value           =   1
      Width           =   1935
   End
   Begin VB.CommandButton HitBox
      Caption         =   "MoveBox"
      Height          =   255
      Left            =   7080
      TabIndex        =   1
      Top             =   5160
      Width           =   1935
   End
   Begin VB.CommandButton Command1
      Caption         =   "Reset"
      Height          =   255
      Left            =   7080
      TabIndex        =   2
      Top             =   4920
      Width           =   1935
   End
   Begin VB.CommandButton RedrawBut
      Caption         =   "Redraw On/Off"
      Height          =   255
      Left            =   7080
      TabIndex        =   3
      Top             =   4680
      Width           =   1935
   End
   Begin VB.Timer Timer1
      Interval        =   1
      Left            =   8400
      Top             =   3720
   End
   Begin VB.Shape Shape1
      BackColor       =   &H00000000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H0000FF00&
      FillColor       =   &H0000FF00&
      FillStyle       =   6  'Cross
      Height          =   255
      Index           =   2
      Left            =   7080
      Top             =   2640
      Width           =   1935
   End
   Begin VB.Shape Shape2
      BackColor       =   &H00000000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H000080FF&
      FillColor       =   &H000080FF&
      FillStyle       =   6  'Cross
      Height          =   255
      Index           =   0
      Left            =   0
      Top             =   9720
      Width           =   2055
   End
   Begin VB.Shape Shape1
      BackColor       =   &H00000000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H0000FF00&
      FillColor       =   &H0000FF00&
      FillStyle       =   6  'Cross
      Height          =   255
      Index           =   4
      Left            =   5280
      Top             =   1440
      Width           =   2295
   End
   Begin VB.Shape Shape1
      BackColor       =   &H00000000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H0000FF00&
      FillColor       =   &H0000FF00&
      FillStyle       =   6  'Cross
      Height          =   255
      Index           =   3
      Left            =   5040
      Top             =   4200
      Width           =   3975
   End
   Begin VB.Shape Shape1
      BackColor       =   &H00000000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H0000FF00&
      FillColor       =   &H0000FF00&
      FillStyle       =   6  'Cross
      Height          =   255
      Index           =   1
      Left            =   0
      Top             =   2640
      Width           =   5415
   End
   Begin VB.Shape Shape1
      BackColor       =   &H00000000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H0000FF00&
      FillColor       =   &H0000FF00&
      FillStyle       =   6  'Cross
      Height          =   255
      Index           =   0
      Left            =   0
      Top             =   5040
      Width           =   1695
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Jared's Collision Detection Engine

Dim Gravity(1000) As Double
Dim ForceL(1000) As Double
Dim ForceR(1000) As Double
Dim XArray(1000) As Integer
Dim YArray(1000) As Integer
Dim Bounce(1000) As Integer
Dim LR(1000) As Boolean
Dim BoxMass(1000) As Single
Dim Floor As Integer
Dim ArraySizer As Integer
' Define Main physics Variables

Dim MouseX As Integer
Dim MouseY As Integer
Dim LineWidth As Byte
Dim Movebox As Boolean
Dim Redraw As Boolean
Dim C As Single
' Define other Variables

Private Sub BallsBar_Change()
ArraySizer = BallsBar.Value
End Sub

Private Sub BallsBar_Scroll()
ArraySizer = BallsBar.Value
End Sub

Private Sub Command1_Click()
Reset
End Sub

Private Sub Form_Activate()
Reset
ArraySizer = 20
Redraw = True
FrameCount = 0
BoxCount = 0
LineWidth = 3
Form1.BackColor = vbBlack
Form1.ForeColor = vbGreen
Movebox = False
End Sub

Private Sub Form_Click()
ShapeTop = Shape1(r).Top
ShapeBot = Shape1(r).Top + Shape1(r).Height
ShapeLeft = Shape1(r).Left
ShapeRight = Shape1(r).Left + Shape1(r).Width
Shape2(r).Top = MouseY - (Shape2(r).Height / 2)
Shape2(r).Left = MouseX - (Shape2(r).Width / 2)
'Reset
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
MouseX = X
MouseY = Y
If Movebox = True Then
Shape2(r).Top = MouseY - (Shape2(r).Height / 2)
Shape2(r).Left = MouseX - (Shape2(r).Width / 2)
End If
End Sub
Public Sub CalcHit()
Dim i As Integer ' Loop and Color Variables
Dim r As Integer
Dim B As Integer

If Redraw = True Then Form1.Cls
Form1.DrawWidth = LineWidth

C = 255 / ArraySizer ' Used For Coloring The Dots

For i = LBound(XArray) To ArraySizer 'Main Drawing Loop

B = i * C ' Used For Coloring The Dots
Form1.ForeColor = RGB(255 - B, 0, 255)

For r = 0 To 4 ' Shape 1 physics loop
    ShapeTop = Shape1(r).Top
    ShapeBot = Shape1(r).Top + Shape1(r).Height
    ShapeLeft = Shape1(r).Left
    ShapeRight = Shape1(r).Left + Shape1(r).Width
'Easier for working out the Platform top, width and bottom etc in If statement

        If XArray(i) >= ShapeLeft And XArray(i) <= ShapeRight And YArray(i) >= ShapeTop And YArray(i) <= ShapeBot Then
            Floor = ShapeTop ' - 3000
            ForceR(i) = 40 + (50 * Rnd)
            ForceL(i) = 40 + (50 * Rnd)
            'Bounce(i) = False
            Gravity(i) = 10 + (20 * Rnd)
        End If
'Shape 1 collision Detection
Next r

For r = 0 To 0 ' Shape 1 physics loop
    ShapeTop = Shape2(r).Top
    ShapeBot = Shape2(r).Top + Shape2(r).Height
    ShapeLeft = Shape2(r).Left
    ShapeRight = Shape2(r).Left + Shape2(r).Width

        If XArray(i) >= ShapeLeft And XArray(i) <= ShapeRight And YArray(i) >= ShapeTop And YArray(i) <= ShapeBot Then
        Floor = ShapeTop ' - 3000
        ForceR(i) = 40 + (50 * Rnd)
        LR(i) = True
        'Bounce(i) = False
        Gravity(i) = 100 + (20 * Rnd)
        End If
'Shape 1 collision Detection
Next r

    If YArray(i) < 0 + 5 Then Bounce(i) = False
    If YArray(i) > Floor - 1000 Then Bounce(i) = True
    If YArray(i) > Form1.Height Then YArray(i) = 0
    If Bounce(i) = True Then YArray(i) = YArray(i) - Gravity(i)
    If Bounce(i) = False Then YArray(i) = YArray(i) + Gravity(i)
    If Bounce(i) = False Then Gravity(i) = Gravity(i) + BoxMass(i)
    If Bounce(i) = True Then Gravity(i) = Gravity(i) - (BoxMass(i) * (1 + Rnd * 1))
    'If Gravity(i) < 0 Then Bounce(i) = 0
    'Up/Down Collision detection and Gravity For each dot

If LR(i) = True And ForceR(i) > 1 Then
    ForceR(i) = ForceR(i) - (ForceR(i) / 100)
    XArray(i) = XArray(i) + ForceR(i)
    End If
If LR(i) = False And ForceL(i) > 1 Then
    ForceL(i) = ForceL(i) - (ForceL(i) / 100)
    XArray(i) = XArray(i) - ForceL(i)
End If

If XArray(i) < 0 Then
    LR(i) = True
    ForceR(i) = ForceL(i)
ElseIf XArray(i) + XArray(i) > 18000 Then
    LR(i) = False
    ForceL(i) = ForceR(i)
End If
    'Left/Right Collision detection and Gravity For each dot

Form1.PSet (XArray(i), YArray(i))
'Simple draw dot at its calculated Position
Next i
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Private Sub HitBox_Click()
Movebox = Not Movebox ' Enables the Box to be moved
If Movebox = True Then
HitBox.Caption = "Movebox Enabled"
Else
HitBox.Caption = "Movebox Not Enabled"
End If
End Sub

Private Sub RedrawBut_Click()
Form1.Cls
Reset
Redraw = Not Redraw
End Sub

Private Sub Timer1_Timer()
CalcHit ' call main draw function
End Sub

Sub Reset()
Dim i As Integer
Dim tempnum As Integer
Randomize
'Reset Arrays
For i = LBound(XArray) To UBound(YArray)
    XArray(i) = 500 + (Rnd * 750) 'form1.Width * Rnd
    YArray(i) = 0
Next i
For i = LBound(BoxMass) To UBound(BoxMass)
BoxMass(i) = 1 ' + (10 * Rnd)
Next i
For i = LBound(Bounce) To UBound(Bounce)
Bounce(i) = False
Next i
For i = LBound(Gravity) To UBound(Gravity)
Gravity(i) = 1 * Rnd
Next i
For i = LBound(LR) To UBound(LR)
tempnum = 1 * Rnd
LR(i) = tempnum
Next i
For i = LBound(ForceR) To UBound(ForceR)
'ForceR(i) = 500 * Rnd
'ForceL(i) = 500 * Rnd
ForceR(i) = 1.1
ForceL(i) = 1.1
Next i

End Sub

Private Sub WideBar_Change()
LineWidth = WideBar.Value
End Sub

Private Sub WideBar_Scroll()
LineWidth = WideBar.Value
End Sub